perm filename GENPAT[2,LMM] blob sn#036307 filedate 1973-04-17 generic text, type T, neo UTF8
(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ") T) (LISPXPRIN1 (QUOTE 
"25-MAR-73 06:43:01") T) (LISPXTERPRI T))
(LISPXPRINT (QUOTE GENPATVARS) T)
(RPAQQ GENPATVARS ((FNS PICK RAND1 ORR PAT PATELT EXPRESSION VAR GENPAT
XLATE LISTOF NUMBER FNNAME TSTPATPARSE DIFFER PATELT1 PATELT2 PATELT3
PRED PATELT4 TMPPATELT UNPATPARSE UNPATPARSELT PACKRAT PACKRAT1) (VARS)
(PROP MACRO ORR LISTOF) (ADVICE PATELT)))
(DEFINEQ

(PICK
(LAMBDA (L) (CAR (NTH L (RAND1 (LENGTH L))))))

(RAND1
(LAMBDA (N) (XLATE (RAND 0.0 1.0) N)))

(ORR
(NLAMBDA L (EVAL (PICK L))))

(PAT
(LAMBDA NIL (* A pattern is a list of at least one PATELT) (LISTOF
(PATELT) 1)))

(PATELT
(LAMBDA NIL (ORR (PATELT1) (PATELT2) (PATELT3) (CONS (QUOTE ←) (CONS
(VAR) (ORR (PATELT2) (PATELT3)))) (CONS (QUOTE ->) (CONS (EXPRESSION)
(ORR (PATELT2) (PATELT3))) (* This is input as (... PATELT ← EXPRESSION
..) and parses this way - Depends, on input, on whether the first
thing can PARSE as a pattern or not)) (CONS (QUOTE !) (ORR (PATELT1)
(PATELT3) (CONS (QUOTE ←) (CONS (VAR) (PATELT3))) (CONS (QUOTE ->)
(CONS (EXPRESSION) (PATELT3))))))))

(EXPRESSION
(LAMBDA (FLG) (ORR (COND (FLG NIL) (T (VAR))) (ORR (NUMBER) (VAR))
(CONS (SETQ FLG (FNNAME)) (COND ((SUBRP FLG) (LIST (EXPRESSION)))
((GETD FLG) (PROG ((X 1) LST (MAX (NARGS FLG))) LP (COND ((IGREATERP
X MAX) (RETURN LST)) (T (SETQ LST (NCONC1 LST (EXPRESSION))))) (SETQ
X (ADD1 X)) (GO LP))) (T (LISTOF (EXPRESSION) 0 3)))))))

(VAR
(LAMBDA NIL (PICK (QUOTE (TUGGLE TICKLE TAG TUMMY TISKET TASKET TRISKET
TRASKET TOOKEY TACKEY EGG BASKET HEAD TAIL FOO BAZ FIDDLE TURKEY TEM
TMP LST EXPR1 STRUC SILLY SALLY LARRY ME SRI WARREN BOB BILL FRED
SHIRLEY TERESA CAROLYNN SUSAN BARBARA MADELYN MARY TED BILL BOB CAROL
ALICE FRANK LES NANCY VICKI XEROX)))))

(GENPAT
(LAMBDA (STARDONE) (PROG (VAL) (PRINTDEF (SETQ VAL (PAT))) (TERPRI)
(RETURN VAL))))

(XLATE
(LAMBDA (N1 N2) (ADD1 (FTIMES N2 (EXPT (FDIFFERENCE N1 1.0) 2)))))

(LISTOF
(NLAMBDA (EXPR MIN MAX) (PROG (VAL (MIN (OR (EVAL MIN) 0)) (MAX (OR
(EVAL MAX) 10))) (RPTQ (IPLUS MIN (RAND1 (IDIFFERENCE MAX MIN))) (SETQ
VAL (CONS (EVAL EXPR) VAL))) (RETURN VAL))))

(NUMBER
(LAMBDA NIL (RAND 2 10)))

(FNNAME
(LAMBDA NIL (PICK (QUOTE (NUMBERP GETD EXPRP ATOM LITATOM STRINGP
FIXP NNIL ZEROP INFILEP LISTP NLISTP MINUSP SMALLP)))))

(TSTPATPARSE
(LAMBDA NIL (SETQ PAT1 (GENPAT)) (PRINT (SETQ PAT2 (UNPATPARSE PAT1)))
(PRINT (SETQ PAT3 (PATPARSE (COPY PAT2)))) (COND ((NOT (SETQ DIFF
(DIFFER PAT1 PAT3))) (QUOTE WIN!)) (T (QUOTE LOSE!!)))))

(DIFFER
(LAMBDA (L1 L2) (COND ((OR (NLISTP L1) (NLISTP L2)) (AND (NOT (EQUAL
L1 L2)) (OR L2 L1))) (T (PROG ((CAR (DIFFER (CAR L1) (CAR L2))) (CDR
(DIFFER (CDR L1) (CDR L2)))) (RETURN (OR (AND CAR CDR (CONS CAR CDR))
CAR CDR)))))))

(PATELT1
(LAMBDA NIL (COND (STARDONE (CONS (QUOTE DEFAULT) (VAR))) (T (OR (CONS
(QUOTE DEFAULT) (VAR)) (PROG1 (QUOTE *) (SETQ STARDONE T)))))))

(PATELT2
(LAMBDA NIL (ORR (QUOTE $) (QUOTE $1) (CONS (QUOTE $$) (ORR (NUMBER)
(EXPRESSION))))))

(PATELT3
(LAMBDA NIL (ORR (CONS (QUOTE :) (PRED)) (PAT))))

(PRED
(LAMBDA NIL (ORR (LIST (CAR (FNTH (QUOTE (EQ EQUAL)) (RAND 1 2)))
(QUOTE X) (ORR (KWOTE (EXPRESSION)) (EXPRESSION))) (FNNAME) (LIST
(FNNAME) (QUOTE X)))))

(PATELT4
(LAMBDA NIL (ORR (PATELT3) (CONS (QUOTE ←) (CONS (VAR) (PATELT3)))
(CONS (QUOTE ->) (CONS (EXPRESSION) (PATELT3))))))

(TMPPATELT
(LAMBDA NIL (ORR (PATELT1) (PATELT2) (PATELT3) (CONS (QUOTE ←) (CONS
(VAR) (ORR (QUOTE $1) (PATELT3)))) (CONS (QUOTE ->) (CONS (EXPRESSION)
(ORR (QUOTE $1) (PATELT3))) (* This is input as (... PATELT ← EXPRESSION
..) and parses this way - Depends, on input, on whether the first
thing can PARSE as a pattern or not)))))

(UNPATPARSE
(LAMBDA (PAT) (* Unpatparse each pattern element and NCONC values
together) (MAPCONC PAT (FUNCTION UNPATPARSELT))))

(UNPATPARSELT
(LAMBDA (PATELT) (* CREATE valid input sytax) (PROG (TEM) (COND ((NLISTP
PATELT) (SELECTQ PATELT (($1 $ *) (LIST PATELT)) (HELP (QUOTE 
"CAN'T UNPATPARSE") PATELT))) (T (SELECTQ (CAR PATELT) (DEFAULT (LIST
(CDR PATELT))) ($$ (COND ((NUMBERP (CDR PAT)) (PACKRAT (QUOTE $) (CDR
PATELT))) ((NLISTP (CDR PATELT)) (PACKRAT (QUOTE $$) (CDR PATELT)))
(T (LIST (CAR PATELT) (CDR PATELT))))) (: (COND ((NLISTP (CDR PATELT))
(PACKRAT (QUOTE :) (CDR PATELT))) ((NOT (EQ (CADDR PATELT) (QUOTE
X))) (LIST (QUOTE :) (CDR PATELT))) ((EQ (CADR PATELT) (QUOTE EQ))
(COND ((EQ (CAR (CADDDR PATELT)) (QUOTE QUOTE)) (PACKRAT (QUOTE ')
(CADR (CADDDR PATELT)))) (T (PACKRAT (QUOTE ==) (CADR (CADDDR PATELT))))))
((EQ (CADR PATELT) (QUOTE EQUAL)) (COND ((EQ (CAR (CADDDR PATELT))
(QUOTE QUOTE)) (PACKRAT (QUOTE ') (CADR (CADDDR PATELT)))) (T (PACKRAT
(QUOTE =) (CADR (CADDDR PATELT)))))) ((NOT (CDDDR PATELT)) (PACKRAT
(QUOTE :) (CADR PATELT))) (T (PACKRAT ': (CDR PATELT))))) (ANY (LIST
(CONS (CAR PATELT) (UNPATPARSE (CDR PATELT))))) (← (NCONC (PACKRAT
(CADR PATELT) (CAR PATELT) (CAR (SETQ TEM (UNPATPARSELT (CDDR PATELT)))))
(CDR TEM))) (-> (PACKRAT (UNPATPARSELT (CDDR PATELT)) (QUOTE ←) (CADR
PATELT))) (! (NCONC (PACKRAT (QUOTE !) (CAR (SETQ TEM (UNPATPARSELT
(CDR PATELT))))) (CDR TEM))) (LIST (UNPATPARSE PATELT))))))))

(PACKRAT
(LAMBDA N (PROG ((CNT N) VAL ATLST) LP (COND ((ZEROP CNT) (RETURN
(PACKRAT1 ATLST VAL))) ((NLISTP (ARG N CNT)) (SETQ ATLST (CONS (ARG
N CNT) ATLST))) (T (SETQ VAL (CONS (ARG N CNT) (PACKRAT1 ATLST VAL)))
(SETQ ATLST))) (SETQ CNT (SUB1 CNT)) (GO LP))))

(PACKRAT1
(LAMBDA (ATLST LST) (COND (ATLST (CONS (PACK ATLST) LST)) (T LST))))
)
(DEFLIST(QUOTE(
(ORR (L (PROG ((TEM 0)) (CONS (QUOTE SELECTQ) (CONS (LIST (QUOTE RAND1)
(LENGTH L)) (NCONC (MAPCAR L (FUNCTION (LAMBDA (X) (LIST (SETQ TEM
(ADD1 TEM)) X)))) (QUOTE ((HELP)))))))))
(LISTOF (L ((LAMBDA (EXPR MIN MAX) (LIST (QUOTE PROG) (QUOTE (VAL))
(LIST (QUOTE RPTQ) (COND (MIN (LIST (QUOTE IPLUS) MIN (LIST (QUOTE
RAND1) (LIST (QUOTE IDIFFERENCE) (OR MAX 10) MIN)))) (T (LIST (QUOTE
RAND1) (OR MAX 10)))) (LIST (QUOTE SETQ) (QUOTE VAL) (CONS (QUOTE
CONS) (CONS EXPR (QUOTE (VAL)))))))) (CAR L) (CADR L) (CADDR L))))
))(QUOTE MACRO))

(DEFLIST(QUOTE(
(PATELT (NIL (BEFORE NIL (RETURN (TMPPATELT)))))
))(QUOTE READVICE))

STOP